home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
PGM_TOOL
/
PREVIEW
/
CLP2DLFI
/
DBSERVER.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1995-11-10
|
41KB
|
1,538 lines
Unit DBFserver;
Interface
Uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls;
Const
TempExprDBF='\accting\comdat\rocket'; { used by DateDiff() }
MaxMemoSize=1000; { set to max memo size you will need }
MaxTags=15;
MaxDBFs=60; { Calc using FILES setting in config.sys, (FILES-20) div 2 }
MaxBrowseFlds=120;
sx_DBFCDX=2;
sx_DBFNTX=1;
sx_DBFNSX=3;
sx_READWRITE=0;
sx_EXCLUSIVE=2;
{ Constants used by sx_Replace() }
r_integer=1;
r_long=2;
r_double=8;
r_julian=32;
r_logical=128;
r_char=1024;
r_datestr=1056;
r_memo=3072;
r_bitmap=4096;
r_blobfile=8192;
Type
String10=string[11]; { used for common declaration when param passing }
String20=string[21];
String30=string[31];
String40=string[41];
String80=string[81];
String135=string[135];
DBFstruct=Class(TObject)
fcount:integer;
fname:array [1..MaxBrowseFlds] of string[11];
fwidth,fdecs:array [1..MaxBrowseFlds] of integer;
ftype:array [1..MaxBrowseFlds] of string[1];
end;
TagInfo=Class(TObject)
tagcnt:integer;
Tags,Keys:array [1..MaxTags] of string[80];
end;
oDB=class(TObject)
public
AliasName:String[11];
Area:integer;
CurOrder:integer;
constructor create(OpenDBF:string;Exclusive:boolean);
procedure Free;
{ Get field info, pass in field name - Return Value of 'fldname' }
function s(fnm:string): string; { full string, no trim() }
function st(fnm:string):string; { trim()'ed value }
function sn(fnm:string;TruncTo:integer):string; { truncate to size }
procedure longs(fnm:string;tp:Pchar);{ fields>255 in length }
function l(fnm:string): longint; { field info as Longint }
function i(fnm:string): integer; { field info as Integer }
function b(fnm:string): boolean; { field info as Boolean }
function n(fnm:string): double; { Numeric field info as Double }
function f(fnm:string): double; { Numeric field info as Double }
procedure m(fnm:string;toPchar:Pchar); { field info as Memo }
function d(fnm:string): Longint; { as longint: 19950115 style }
function ds(fnm:string): string; { as string: 10-15-95 style }
function dj(fnm:string):longint; { as Julian date }
{ Replace field with "newval", pass in field name
and var of appropriate data type as needed - Replace 'fnm' with }
procedure ss(fnm:string;newval:string); { String }
procedure longss(fnm:string;tp:Pchar);{ Char fields>255 in length }
procedure ll(fnm:string;newval:longint); { Longint }
procedure ii(fnm:string;newval:integer); { Integer }
procedure bb(fnm:string;newval:boolean); { Boolean }
procedure ff(fnm:string;newval:double); { Double }
procedure nn(fnm:string;newval:double); { Double }
procedure mm(fnm:string;newval:pchar); { Memo (Pchar) }
procedure dd(fnm:string;newval:longint); { Longint NewVal: 19950115 }
{ Database commands }
function Alias:string;
procedure Append;
function Bof:Boolean;
procedure CreateIndex(TagName,TagKey:string);
procedure Delete; { mark record as deleted }
function Deleted: boolean; { status of deletion flag for record }
function Eof: boolean;
procedure GetDBFstruct(SaveTo:DBFstruct);
function GetFullRecord:string; {return raw data, first 255 bytes only }
procedure Go(RecNo:longint); { GoTo is reserved word, not used }
procedure GoBottom;
procedure GoTop;
function Lastrec:longint;
function Lock: boolean; { try lock until succeeds }
function aLock: boolean; { try a few times, then return if fails }
function LockList(var locklist:array of longint):integer;
procedure Pack;
function RecCount: longint;
function RecNo: longint;
procedure Recall; { unmark record as deleted }
procedure ReIndex;
function Seek(apattern:string): boolean;
procedure SetOrder(ToIndex:integer); { by tag number }
procedure SetRelation(IntoAreaNum:integer;OnExpr:string);
procedure Skip;
procedure Skip2(ByCnt:integer);
procedure TagOrder(OrderByTag:String); { by tag name }
procedure unLock;
procedure Zap;
end;
{ Public Variables and Functions }
var DBFname:array [1..MaxDBFs] of string[50];
procedure StartDBserver;
procedure StopDBserver; { Release resources }
procedure Beep;
function cdow(aDow:integer):string; { day of week, Monday, etc }
function cMonth(aMonth:integer):string; { month, January, etc }
function CoreFile(FullPath:string):string;
procedure CreateDBF(DBFname:string;FldCnt:integer;
var FieldName,FldType:array of String; var FldWidth,FldDecs:array of integer);
function ctod(DateStr:String):Longint; { ctod('01/15/95') -> 19950115 }
function DateDiff(Date1Minus,Date2:longint):longint;
function datehyph(adate:longint):string; { date to string type of ' 1-15-95' }
function DateMath(DateLong:Longint;PlusMinus:Longint):Longint;
function dbUse(var pDBF:odb;aDBF:string):boolean;
function dbUseExclusive(var pDBF:odb;aDBF:string):boolean;
function dbAlias:string;
procedure dbClose(var aDB:oDB);
function dbIndexOrd:integer;
function dbIsOpen(aDB:oDB):boolean;
function dbIsClosed(aDB:oDB):boolean;
function dbSelect(AnAlias:string):integer;
function dbSelectArea(ByAreaNum:integer):string;
procedure DoEvents2;
procedure DoEvents;
function dow(DateAslong:Longint):integer; { day of week, Sun=1 }
function dshyph(ddd:longint):string; { Special Date string conversion }
function dtoc(DateLong:LongInt):String; { dtoc(19940115) -> '01/15/94' }
function dtos(DateLong:Longint):String; { dtos(19940115) -> '19940115' }
function Empty(aStr:String):Boolean; { date strings and regular strings }
function EvalExpr(StrExpr:String):String;
function GetEnv(envname:string):string; { Get Environment String Value }
function GetUniqueAlias(StartWith:string):string;
procedure GetWinSection(SectionName:string;var slist:array of string);
function GetWinSetting(SectionName,KeyName:string):string;
procedure LoadTags(aDBF:oDB;var TagDat:TagInfo);
function Lower(aStr:String):String;
function lTransform(aLongInt:Longint;WithPict:String):String;
function lTrim(aStr:String):String; { trim off leading spaces }
function Month(aDate:longint):integer; { month, 1-12 }
procedure OKbox(sText:String);
function PadC(aStr:String;InWidth:Integer):String; { pad center in width }
function PadL(aStr:String;InWidth:Integer):String; { right justify in width }
function PadR(aStr:String;InWidth:Integer):String; { left justify in width }
function pp(var anInt:integer):integer; { ii:=ii+1 ==> pp(ii) }
function pp2(var anInt,adjby:integer):integer; { ii+=14 ==> pp2(ii,14) }
function ProcDbl(nval:string):double; { accepts any string }
function ProcInt(nval:string):integer; { accepts any string }
function ProcLong(nval:string):longint; { accepts any string }
procedure PutWinSetting(SectionName,KeyName,NewValue:string);
function Replicate(aStr:String;ForCnt:integer):String; { truncates to 255 }
function RocketVersion:string;
function Space(EmptySize:Integer):String; { return string of spaces }
function stod(LongStr:String):Longint; { stod('19940115') -> 19940115 }
function Str(aDbl:double;width,decs:integer):string;
function Str2(aDbl:double;width:integer):string;
function StrI(aInt:longint;width:integer):string;
function StrD(aDbl:double;ToPlaces:integer):string;
function Stuff(aStr:string;At,ForLen:integer;WithStr:string):string;
function SubStr(aStr:String;Start:Integer;Count:Integer):String;
function Transform(aDouble:Double;WithPict:String):String;
function Trim(aStr:String):String; { trim off trailing spaces }
procedure TrimStr(aPchar:Pchar);
function Upper(aStr:String):String;
function ValidDate(DateAsLong:Longint):Boolean; { date valid? }
function xDate:longint; { date() replacement compatible with above }
function Year(aDate:longint):integer; { year of date, 1995 }
function YesNoBox(text:string):boolean;
function YesNoCancelBox(text:string):integer; { yes-6, no-2, cancel-7 }
function YN(aBool:Boolean):String; {Convert Boolean to string, 'Y','N' }
Implementation
uses WYNform;
var StrNull1,StrNull2:Pchar; { used by several commands }
DoEventsCnt:integer;
function GetDOSEnvironment:Pchar;far;external 'KERNEL';
{ the following were translated from /rocket/sixcpp/stdafx.h }
procedure sx_AppendBlank; far; external 'ROCKET';
function sx_Alias(AreaNo:Integer):Pchar; far; external 'ROCKET';
function sx_Bof:Integer; far; external 'ROCKET';
procedure sx_Close; far; external 'ROCKET';
procedure sx_CloseAll; far; external 'ROCKET';
procedure sx_Commit; far; external 'ROCKET';
function sx_CreateNew(DBFname,alias:pchar;IndexType,NumOfFields:integer):integer;
far; external 'ROCKET';
procedure sx_CreateField(fnm,FldType:pchar;Fwidth,Fdecs:integer);
far; external 'ROCKET';
function sx_CreateExec:boolean; far; external 'ROCKET';
procedure sx_DBRlockList(ptr:pointer); far; external 'ROCKET';
procedure sx_Delete; far; external 'ROCKET';
function sx_Deleted:Integer; far; external 'ROCKET';
function sx_Eof:Integer; far; external 'ROCKET';
function sx_EvalString(Expr:Pchar):Pchar; far; external 'ROCKET';
function sx_FieldCount:Integer; far; external 'ROCKET';
function sx_FieldName(fnum:Integer):Pchar; far; external 'ROCKET';
function sx_FieldNum(fnm:Pchar):Integer; far; external 'ROCKET';
function sx_FieldDecimals(fnm:Pchar):Integer; far; external 'ROCKET';
function sx_FieldType(fnm:Pchar):Pchar; far; external 'ROCKET';
function sx_FieldWidth(fnm:Pchar):Integer; far; external 'ROCKET';
function sx_Found:Integer; far; external 'ROCKET';
function sx_GetDateJulian(fnm:Pchar):Longint; far; external 'ROCKET';
function sx_GetDateString(fnm:Pchar):Pchar; far; external 'ROCKET';
function sx_GetDouble(fnm:Pchar):Double; far; external 'ROCKET';
function sx_GetInteger(fnm:Pchar):Integer; far; external 'ROCKET';
function sx_GetLogical(fnm:Pchar):Integer; far; external 'ROCKET';
function sx_GetLong(fnm:Pchar):Longint; far; external 'ROCKET';
function sx_GetMemo(fnm:Pchar;LineWidth:Integer):Pchar;
far; external 'ROCKET';
procedure sx_GetRecord(IntoBuffer:Pchar); far; external 'ROCKET';
function sx_GetString(fnm:Pchar):Pchar; far; external 'ROCKET';
function sx_GetTrimString(fnm:Pchar):Pchar; far; external 'ROCKET';
procedure sx_Go(ToRec:LongInt); far; external 'ROCKET';
procedure sx_GoBottom; far; external 'ROCKET';
procedure sx_GoTop; far; external 'ROCKET';
function sx_IndexOrd:Integer; far; external 'ROCKET';
function sx_IndexKey:Pchar; far; external 'ROCKET';
function sx_IndexTag(DBFname,TagName,TagKey:pchar;
bUnique,bDescending:boolean;CondExpr:pchar):integer;
far; external 'ROCKET';
function sx_Locked(RecNo:LongInt):Integer; far; external 'ROCKET';
function sx_LockCount:integer; far; external 'ROCKET';
procedure sx_MemDealloc(aPointer:Pchar); far; external 'ROCKET';
procedure sx_Pack; far; external 'ROCKET';
procedure sx_Recall; far; external 'ROCKET';
function sx_RecCount:Longint; far; external 'ROCKET';
function sx_RecNo:Longint; far; external 'ROCKET';
function sx_RecSize:Longint; far; external 'ROCKET';
procedure sx_ReIndex; far; external 'ROCKET';
procedure sx_Replace(fnm:Pchar;FldType:Integer;PtrData:Pchar);
far; external 'ROCKET';
function sx_Rlock(RecNo:Longint):Integer; far; external 'ROCKET';
function sx_Seek(aPattern:Pchar):Integer; far; external 'ROCKET';
function sx_Select(AreaNo:Integer):Integer; far; external 'ROCKET';
procedure sx_SetDeleted(OnOff:Integer); far; external 'ROCKET';
procedure sx_SetExact(OnOff:Integer); far; external 'ROCKET';
function sx_SetHandles(ToCnt:Integer):Integer; far; external 'ROCKET';
function sx_SetOrder(ToIndexNo:Integer):Integer; far; external 'ROCKET';
procedure sx_SetRelation(IntoArea:integer;UseExpr:Pchar); far;
external 'ROCKET';
procedure sx_SetStringType(cstyle:Integer); far; external 'ROCKET';
procedure sx_Skip(MoveCnt:Longint); far; external 'ROCKET';
function sx_TagArea(TagName:Pchar):Integer; far; external 'ROCKET';
function sx_TagName(TagIndex:Integer):Pchar; far; external 'ROCKET';
procedure sx_Unlock(RecNo:Longint); far; external 'ROCKET';
function sx_Use(Fname:pchar;dAlias:pchar;OpenMode:Integer;
RDDtype:Integer): Integer;
far; external 'ROCKET';
function sx_Version:pchar; far; external 'ROCKET';
function sx_WorkArea(AliasName:Pchar):Integer; far; external 'ROCKET';
procedure sx_Zap; far; external 'ROCKET';
function RocketVersion:string;
begin
result:=strpas(sx_Version);
end;
function YesNoBox(text:string):boolean;
var ret:integer;
tyn:TYNform;
begin
tyn:=TYNform.create(application);
tyn.setup(2,'Job Cost',text);
ret:=tyn.showmodal;
Result:=(ret=mrYES);
end;
function YesNoCancelBox(text:string):integer; { yes-6, no-2, cancel-7 }
var tyn:TYNform;
begin
tyn:=TYNform.create(application);
tyn.setup(3,'Job Cost',text);
Result:=tyn.showmodal;
end;
procedure OKbox(sText:String);
var tyn:TYNform;
begin
tyn:=TYNform.create(application);
tyn.setup(1,'Job Cost',stext);
tyn.showmodal;
end;
procedure GetWinSection(SectionName:string;var slist:array of string);
var tp,p1,p2,p3,p4:pchar;
ii:integer;
begin
p1:=stralloc(120);
p2:=nil;
p3:=stralloc(120);
p4:=stralloc(800);
strpcopy(p1,SectionName);
strpcopy(p3,'');
strpcopy(p4,'');
GetProfileString(p1,p2,p3,p4,798);
tp:=p4; { must use second var because we're changing a pointer }
for ii:=0 to high(slist) do slist[ii]:='';
ii:=-1;
{ note only the text before the '=' is returned, not the whole line
you have to make a second call with GetWinSetting() to get the
rest of the line }
while (tp^<>#0) and (ii<high(slist)) do begin
pp(ii);
slist[ii]:=strpas(tp);
inc(tp,length(slist[ii])+1);
end;
strdispose(p1);
strdispose(p3);
strdispose(p4);
end;
function GetWinSetting(SectionName,KeyName:string):string;
var p1,p2,p3,p4:pchar;
begin
p1:=stralloc(120);
p2:=stralloc(120);
p3:=stralloc(120);
p4:=stralloc(120);
strpcopy(p1,SectionName);
strpcopy(p2,KeyName);
strpcopy(p3,'');
strpcopy(p4,'');
GetProfileString(p1,p2,p3,p4,120);
Result:=strpas(p4);
strdispose(p1);
strdispose(p2);
strdispose(p3);
strdispose(p4);
end;
procedure PutWinSetting(SectionName,KeyName,NewValue:string);
var p1,p2,p3,p4:pchar;
begin
p1:=stralloc(120);
p2:=stralloc(120);
p3:=stralloc(120);
strpcopy(p1,SectionName);
strpcopy(p2,KeyName);
strpcopy(p3,NewValue);
WriteProfileString(p1,p2,p3);
strdispose(p1);
strdispose(p2);
strdispose(p3);
end;
function getenv(envname:string):string;
var buf1:pchar;
tb:array [0..2000] of char;
ii,tcnt,jj,kk:integer;
tt,utt:string;
tlist:array [1..30] of string[130];
begin
buf1:=tb;
buf1:=GetDOSEnvironment;
tcnt:=0;
tt:=strpas(buf1);
utt:=uppercase(tt);
Result:='';
envname:=uppercase(envname);
jj:=pos('=',utt);
if pos(envname,utt)>0 then begin
Result:=copy(tt,jj+1,128);
exit;
end;
while (length(tt)>0) and (tcnt<30) do begin
pp(tcnt);
tlist[tcnt]:=tt;
buf1:=buf1+length(tt)+1;
tt:=strpas(buf1);
utt:=uppercase(tt);
envname:=uppercase(envname);
jj:=pos('=',utt);
if pos(envname,utt)>0 then begin
Result:=copy(tt,jj+1,128);
break;
end;
end;
end;
function Space(EmptySize:Integer):String; { return string of spaces }
var tt,tt2:string;
ii:integer;
begin
tt:=' ';
tt2:='';
for ii:=1 to 5 do tt2:=tt2+tt;
ii:=length(tt2);
Result:=copy(tt2,1,EmptySize);
end;
function datehyph(adate:longint):string;
var ii:integer;
ds,tt,tt2:string[10];
begin
ds:=dtoc(adate);
if not empty(ds) then begin
tt2:='';
for ii:=1 to 8 do begin
tt:=substr(ds,ii,1);
if (ii=1) and (tt='0') then tt:=' ';
if tt='/' then tt:='-';
tt2:=tt2+tt;
end;
result:=tt2;
end else Result:=space(8);
end;
function NoDashDate(adate:string):string;
var ii,jj:integer;
tt,tt2:string[10];
begin
result:=adate;
if pos('-',adate)>0 then begin
tt2:='';
jj:=length(adate);
for ii:=1 to jj do begin
tt:=substr(adate,ii,1);
if tt='-' then tt:='/';
tt2:=tt2+tt;
end;
result:=tt2;
end;
end;
function pp(var anInt:integer):integer; { ii:=ii+1 ==> pp(ii) }
begin
result:=anInt; { usage: lp.p(line++,5,'Hi') -> lp.p(pp(line),5,'Hi') }
anInt:=anInt+1;
end;
function pp2(var anInt,adjby:integer):integer; { ii+=14 ==> pp2(ii,14) }
begin
result:=anInt;
anInt:=anInt+adjby;
end;
function ProcInt(nval:string):integer;
var tdbl:double;
begin
tdbl:=ProcDbl(nval);
result:=StrToInt(ltrim(transform(tdbl,'99999999')));
end;
function ProcLong(nval:string):longint;
var tdbl:double;
begin
tdbl:=ProcDbl(nval);
result:=StrToInt(ltrim(transform(tdbl,'99999999')));
end;
function procdbl(nval:string):double;
var decs,prnum,jj:double;
ii:integer;
ist:string[30];
pastdec,isminus:boolean;
begin
prnum:=0.00;
pastdec:=False;
isminus:=False;
decs:=1.0;
if not empty(nval) then begin
for ii:=1 to length(nval) do begin
ist:=Copy(nval,ii,1);
if ist='-' then begin
isminus:=True;
End;
if ist='.' then begin
pastdec:=True;
End Else
Begin
if (ist >= '0') And (ist <= '9') then begin
jj:=StrToFloat(ist);
prnum := prnum * 10.0;
prnum := prnum + jj;
if pastdec then begin
decs:=decs / 10.0;
End;
End;
End;
End;
if isminus then begin
prnum:=prnum * decs * -1;
End Else
Begin
prnum:=prnum * decs;
End;
if Not pastdec then begin
prnum:=int(prnum);
End;
end;
Result:=prnum;
end;
function dshyph(ddd:longint):string;
var tt,tt2:string[20];
begin
if ddd=ctod('01/01/99') then
Result:=' W/A '
else begin
if ddd=ctod('12/01/99') then
Result:=' 4-STOCK'
else begin
tt:=dtos(ddd);
tt2:=substr(tt,5,2);
tt:=substr(tt,3,2);
if tt='99' then
Result:=padl(inttostr(strtoint(tt2))+'-WARM',8)
else begin
if ddd>ctod('01/01/99') then
Result:='BAD DATE'
else
Result:=datehyph(ddd);
end;
end;
end;
end;
function PadC(aStr:String;InWidth:Integer):String; { pad center in width }
var ii,ll:integer;
begin
ll:=length(aStr);
if ll>=InWidth then Result:=copy(aStr,1,Inwidth) { truncate }
else begin
ii:=(InWidth-ll) div 2;
if ii>0 then Result:=space(ii)+aStr;
ll:=length(Result);
if ll<InWidth then Result:=Result+space(InWidth-ll)
end;
end;
function PadL(aStr:String;InWidth:Integer):String; { right justify in width }
var ll:integer;
begin
ll:=length(aStr);
if ll>=InWidth then Result:=copy(aStr,1,Inwidth) { truncate }
else Result:=space(InWidth-ll)+aStr;
end;
function PadR(aStr:String;InWidth:Integer):String; { left justify in width }
var ll:integer;
begin
ll:=length(aStr);
if ll>=InWidth then Result:=copy(aStr,1,Inwidth) { truncate }
else Result:=aStr+space(InWidth-ll);
end;
function YN(aBool:Boolean):String;
begin
Result:='N';
if aBool then Result:='Y';
end;
function dow(DateAslong:Longint):integer; { day of week, Sun=1 }
var tdate:TDateTime;
tt,tt2:string[20];
begin
if DateAsLong>0 then begin
tt:=IntToStr(DateAsLong);
tt2:=copy(tt,5,2)+'/'+copy(tt,7,2)+'/'+copy(tt,1,4);
tdate:=StrToDate(tt2);
Result:=DayOfWeek(tdate);
end else Result:=0;
end;
function cdow(aDow:integer):string;
begin
Result:='Unknown';
case aDOW of
1:Result:='Sunday';
2:Result:='Monday';
3:Result:='Tuesday';
4:Result:='Wednesday';
5:Result:='Thursday';
6:Result:='Friday';
7:Result:='Saturday';
end;
end;
function month(aDate:longint):integer;
var tt:string;
begin
Result:=0;
if aDate>0 then begin
Result:=strtoint(copy(inttostr(aDate),5,2));
end;
end;
function cmonth(aMonth:integer):string;
begin
Result:='Unknown';
case aMonth of
1:Result:='January';
2:Result:='February';
3:Result:='March';
4:Result:='April';
5:Result:='May';
6:Result:='June';
7:Result:='July';
8:Result:='August';
9:Result:='September';
10:Result:='October';
11:Result:='November';
12:Result:='December';
end;
end;
function year(aDate:longint):integer;
var tt:string;
begin
Result:=0;
if aDate>0 then begin
Result:=strtoint(copy(inttostr(aDate),1,4));
end;
end;
function StrI(aInt:longint;width:integer):string;
begin
Result:=ltransform(aInt,copy('99999999',1,width))
end;
function ValidDate(DateAslong:Longint):Boolean; { date valid? }
var tdate:TDateTime;
tt,tt2:string[20];
begin
Result:=true;
if DateAsLong>0 then begin { Zero (empty date) is always valid }
try
tt:=padr(IntToStr(DateAsLong),8);
tt2:=copy(tt,5,2)+'/'+copy(tt,7,2)+'/'+copy(tt,1,4);
tdate:=StrToDate(tt2);
Result:=True; { if we made it here, it was OK }
except
{ Must turn-off option on Environment Options window
"Break on Exception" in "Debugging" section while testing }
Result:=False;
end;
end;
end;
procedure TrimStr(aPchar:Pchar);
var tp:Pchar;
ii:integer;
begin
if strlen(apchar)>0 then begin
tp:=apchar;
inc(tp,strlen(apchar)-1);
while true do begin
if tp^<>#32 then begin
inc(tp,1);
tp^:=#0;
break;
end;
if tp=apchar then break;
inc(tp,-1);
end;
ii:=strlen(apchar);
if tp=apchar then apchar^:=#0;
end;
end;
function Trim(aStr:String):String; { trim off trailing spaces }
var ii,kk,ll:integer;
begin
ll:=length(aStr);
Result:=aStr;
if ll>0 then begin
kk:=0;
for ii:=ll downto 1 do begin
if aStr[ii]<>#32 then begin
kk:=ii;
break;
end;
end;
if kk>0 then Result:=copy(astr,1,kk)
else Result:='';
end;
end;
function stuff(aStr:string;At,ForLen:integer;WithStr:string):string;
var front,back:string;
begin
front:='';
back:='';
if At>1 then front:=copy(aStr,1,at-1);
if At<length(aStr) then back:=copy(aStr,at+ForLen,255);
Result:=front+WithStr+back;
end;
function SubStr(aStr:String;Start:Integer;Count:Integer):String; { same as copy() }
begin
{ substr() same args as Delphi copy() }
Result:=Copy(aStr,Start,Count);
end;
function Replicate(aStr:String;ForCnt:integer):String;
var ii,jj:integer;
tt:string;
begin
jj:=length(astr)*ForCnt;
if jj>255 then begin
ii:=255 div jj;
end;
tt:='';
for ii:=1 to jj do tt:=tt+aStr;
Result:=tt;
end;
function Upper(aStr:String):String; { same as uppercase }
begin
Result:=UpperCase(aStr);
end;
function Lower(aStr:String):String;
begin
Result:=LowerCase(aStr);
end;
function lTrim(aStr:String):String; { trim off trailing spaces }
var ii,kk,ll:integer;
begin
ll:=length(aStr);
Result:=aStr;
if ll>0 then begin
kk:=0;
for ii:=1 to ll do begin
if aStr[ii]<>#32 then begin
kk:=ii;
break;
end;
end;
if kk>0 then Result:=copy(astr,kk,254)
else Result:='';
end;
end;
function Empty(aStr:String):Boolean;
var ii,ll:integer;
res:boolean;
begin
if length(aStr)=0 then res:=true
else
begin
ll:=length(aStr);
if (ll=8) or (ll=10) then { check for date? }
begin
if (aStr[3]=#47) and (aStr[6]=#47) then { chars 3 and 6 are "/" }
begin
ll:=2; { only need to test first 2 chars of dates }
if pos('00',aStr)=1 then ll:=0 { ignore '00/00/00' }
end;
end;
res:=True;
if ll>0 then begin
for ii:=1 to ll do begin
if aStr[ii]<>#32 then begin
res:=False;
break;
end;
end;
end;
end;
Result:=res;
end;
{ True/False tester for DLL boolean (integer) return values }
function tf(AnInt:Integer):Boolean;
begin
Result:=AnInt<>0; { True=Any Non-Zero Value }
end;
procedure StopDBserver;
begin
sx_CloseAll;
StrDispose(StrNull1);
StrDispose(StrNull2);
end;
procedure delay(ForSeconds:integer);
{ delay for interval in seconds }
var tt:TDateTime;
hr,thr,mn,sc,ms:word;
ll,cur,rng:LongInt;
begin
tt:=now;
rng:=ForSeconds;
DecodeTime(tt,hr,mn,sc,ms);
thr:=hr;
cur:=(hr*3600)+(mn*60)+sc;
ll:=(hr*3600)+(mn*60)+sc;
while rng>(ll-cur) do begin
tt:=now;
DecodeTime(tt,hr,mn,sc,ms);
if hr<thr then hr:=hr+24; { anyone work at midnight? }
ll:=(hr*3600)+(mn*60)+sc;
end;
end;
function EvalExpr(StrExpr:String):String;
begin
{ An error will occur if no DBF's are open }
Result:=StrPas(sx_EvalString(StrPCopy(StrNull1,StrExpr)));
end;
function ctod(DateStr:String):Longint; { ctod('01/15/95') -> 19950115 }
var tt:string;
begin
{ pass in date string of form '01/15/94' }
DateStr:=NoDashDate(DateStr); { convert 00-00-00 to 00/00/00 first }
if empty(DateStr) then Result:=0
else begin
tt:=EvalExpr('ctod("'+DateStr+'")');
if empty(tt) then Result:=0
else Result:=StrToInt(tt);
end;
end;
function dtoc(DateLong:LongInt):String; { dtoc(19940115) -> '01/15/94' }
begin
{ pass in date as longint of form 19940115 }
Result:=' / / ';
if (DateLong>0) and ValidDate(DateLong) then
Result:=EvalExpr('dtoc(stod("'+IntToStr(DateLong)+'"))');
end;
function dtos(DateLong:Longint):String; { dtos(19940115) -> '19940115' }
begin
{ pass in date as longint of form 19940115 }
Result:=space(8);
if (DateLong>0) and ValidDate(DateLong) then
Result:=EvalExpr('dtos(stod("'+IntToStr(DateLong)+'"))');
end;
function stod(LongStr:String):Longint; { stod('19940115') -> 19940115 }
var tt:string[20];
begin
{ pass in date string of form '19940115' }
if empty(LongStr) then tt:='0'
else tt:=LongStr;
if not ValidDate(StrToInt(tt)) then Result:=0
else Result:=StrToInt(EvalExpr('stod("'+LongStr+'")'));
end;
function DateDiff(Date1Minus,Date2:longint):longint;
var tt:string;
CurAlias:integer;
ddb:oDB;
begin
{ pass in date string of form 19940115 }
Result:=-10000; { arbitrary error return value }
ddb:=Nil;
dbUse(ddb,TempExprDBF);
if ddb.aLock then begin
if empty(dtoc(Date1Minus)) Or empty(dtoc(Date2)) then Result:=-10000
else begin
ddb.dd('date1',Date1Minus);
ddb.dd('date2',Date2);
Result:=ddb.dj('date1')-ddb.dj('date2');
end;
end;
ddb.Free;
end;
function DateMath(DateLong:Longint;PlusMinus:Longint):Longint;
var tt:string[10];
begin
if PlusMinus<0 then tt:='' { need to add sign for plus numbers }
else tt:='+';
{ pass in date string of form '19940115' }
Result:=StrToInt(EvalExpr('dtos(stod("'+IntToStr(DateLong)+'")'+tt+
IntToStr(PlusMinus)+')'));
end;
function Transform(aDouble:Double;WithPict:String):String;
begin
Result:=EvalExpr('transform('+format('%13.4f',[aDouble])+
',"'+WithPict+'")');
end;
function lTransform(aLongInt:Longint;WithPict:String):String;
begin
Result:=EvalExpr('transform('+IntToStr(aLongInt)+
',"'+WithPict+'")');
end;
function Str2(aDbl:double;width:integer):string;
begin
Result:=str(aDbl,Width,0);
end;
function StrD(aDbl:double;ToPlaces:integer):string;
var InWidth:integer;
begin
InWidth:=8;
if ToPlaces>0 then InWidth:=8+1+ToPlaces;
Result:=ltrim(str(aDbl,InWidth,ToPlaces));
end;
function str(aDbl:double;width,decs:integer):string;
var nines,before,after:string[30];
ii:integer;
begin
nines:='99999999999999';
if decs>0 then begin
ii:=width-(decs+1);
before:=copy(nines,1,ii);
after:='.'+copy(nines,1,decs);
end else begin
before:=copy(nines,1,width);
after:='';
end;
Result:=transform(aDbl,before+after);
end;
function xDate:longint;
begin
Result:=StrToInt(EvalExpr('date()'));
end;
function dbIndexOrd:integer;
begin
Result:=sx_IndexOrd;
end;
procedure LoadTags(aDBF:oDB;var TagDat:TagInfo);
var ii,CurIndex:integer;
begin
sx_Select(aDBF.Area);
with TagDat do begin
tagcnt:=0;
CurIndex:=sx_IndexOrd;
for ii:=1 to MaxTags do begin
tags[ii]:=StrPas(sx_TagName(ii));
if length(tags[ii])>0 then begin
pp(tagcnt);
sx_SetOrder(ii);
keys[ii]:=StrPas(sx_IndexKey);
end else break;
end;
end;
sx_SetOrder(CurIndex);
end;
function CoreFile(FullPath:string):string;
var ii:integer;
{ Get core file name for aliases, no path, no extension }
begin
ii:=pos('\',FullPath);
while ii>0 do begin
FullPath:=Copy(FullPath,ii+1,100);
ii:=pos('\',FullPath);
end;
ii:=pos('.',FullPath);
if ii>1 then FullPath:=Copy(FullPath,1,ii-1);
Result:=upper(FullPath);
end;
function GetUniqueAlias(StartWith:string):string;
var ii,kk,ll:integer;
begin
kk:=sx_WorkArea(strpcopy(strnull1,StartWith));
ll:=length(StartWith);
if ll>8 then ll:=8;
{ check to see if it already exists, if so try something else }
ii:=2;
while kk>0 do begin
StartWith:=upper(copy(StartWith,1,ll))+inttostr(ii);
pp(ii);
kk:=sx_WorkArea(strpcopy(strnull1,StartWith));
end;
Result:=StartWith;
end;
procedure CreateDBF(DBFname:string;FldCnt:integer;
var FieldName,FldType:array of String;
var FldWidth,FldDecs:array of integer);
var aliasname:string;
ii:integer;
begin
aliasname:=CoreFile(dbfname);
if FileExists(dbfname+'.dbf') then begin
if YesNoBox('CREATE DBF - File Exists: '+
upper(dbfname+'.dbf')+', Delete First') then begin
DeleteFile(dbfname+'.dbf');
if FileExists(dbfname+'.cdx') then DeleteFile(dbfname+'.cdx')
end else Exit;
end;
sx_CreateNew(StrPCopy(StrNull1,DBFname+'.dbf'),
StrPCopy(StrNull2,aliasname),sx_DBFCDX,high(FieldName)+1);
for ii:=0 to FldCnt-1 do begin
if not empty(FieldName[ii]) then
sx_CreateField(StrPCopy(StrNull1,upper(FieldName[ii])),
StrPCopy(StrNull2,upper(FldType[ii])),FldWidth[ii],FldDecs[ii]);
end;
sx_CreateExec;
sx_Close;
end;
procedure oDB.CreateIndex(TagName,TagKey:string);
{ assumes DBF opened with UseExclusive }
begin
sx_Select(Area);
sx_IndexTag(Nil,StrPCopy(StrNull1,upper(TagName)),
StrPCopy(StrNull2,upper(TagKey)),False,False,Nil);
end;
procedure oDB.GetDBFstruct(SaveTo:DBFstruct);
var ii:integer;
begin
sx_Select(Area);
with SaveTo do begin
fcount:=sx_FieldCount;
if fcount>MaxBrowseFlds then fcount:=MaxBrowseFlds; { sxBrowse limit }
if fcount>0 then begin
for ii:=1 to fcount do begin
fname[ii]:=StrPas(sx_FieldName(ii));
ftype[ii]:=StrPas(sx_FieldType(StrPCopy(StrNull1,fname[ii])));
fwidth[ii]:=sx_FieldWidth(StrPCopy(StrNull1,fname[ii]));
fdecs[ii]:=sx_FieldDecimals(StrPCopy(StrNull1,fname[ii]));
end;
end;
end;
end;
procedure Beep;
begin
MessageBeep(MB_OK);
end;
procedure DoEvents;
begin
Application.ProcessMessages;
end;
procedure DoEvents2;
begin
pp(DoEventsCnt);
if DoEventsCnt=8 then begin
Application.ProcessMessages;
DoEventsCnt:=0;
end;
end;
function dbAlias:string;
begin
if sx_WorkArea(Nil)>0 then
Result:=StrPas(sx_Alias(0))
else Result:='';
end;
procedure dbClose(var aDB:oDB);
begin
if aDB<>Nil then begin
aDB.Free;
aDB:=Nil;
end;
end;
function dbIsClosed(aDB:oDB):boolean;
begin
Result:=(aDB=Nil);
end;
function dbIsOpen(aDB:oDB):boolean;
begin
Result:=(aDB<>Nil);
end;
function dbUse(var pDBF:odb;aDBF:string):boolean;
begin
result:=false;
if pDBF<>Nil then begin
OKBox('Error, Attempted To Open With Non-Nil Handle? '+
upper(DBFname[pDBF.Area]));
end else begin
pDBF:=oDB.Create(aDBF,false);
result:=(pDBF.area>0); { check area number to see if opened OK }
end;
end;
function dbUseExclusive(var pDBF:odb;aDBF:string):boolean;
begin
result:=false;
if pDBF<>Nil then begin
OKBox('Error, Attempted To Open With Non-Nil Handle? '+
upper(DBFname[pDBF.Area]));
end else begin
pDBF:=oDB.Create(aDBF,true);
result:=(pDBF.area>0); { check area number to see if opened OK }
end;
end;
function dbSelect(AnAlias:string):integer;
begin
Result:=sx_WorkArea(strpcopy(strnull1,AnAlias));
end;
function dbSelectArea(ByAreaNum:integer):string;
var tt:string[20];
ii:integer;
begin
Result:='';
ii:=sx_workarea(nil); { make sure at least one area open }
if sx_WorkArea(Nil)>0 then begin
tt:=StrPas(sx_Alias(ByAreaNum));
if Not Empty(tt) then begin
Result:=tt; { return alias name in ByAreaNum }
end;
end;
end;
constructor oDB.create(OpenDBF:string;Exclusive:boolean);
var ii:integer;
begin
inherited create;
Area:=0;
AliasName:=GetUniqueAlias(CoreFile(OpenDBF));
if not FileExists(OpenDBF+'.dbf') then
ShowMessage('DBF not found: '+upper(OpenDBF+'.dbf'));
if Exclusive then
ii:=sx_Use(StrPCopy(StrNull1,OpenDBF),
StrPCopy(StrNull2,aliasname),sx_EXCLUSIVE,sx_DBFCDX)
else
ii:=sx_Use(StrPCopy(StrNull1,OpenDBF),
StrPCopy(StrNull2,aliasname),sx_READWRITE,sx_DBFCDX);
if ii>0 then begin
DBFname[ii]:=upper(OpenDBF);
Area:=ii;
SetOrder(1);
end;
end;
procedure oDB.Free;
begin
sx_Select(Area);
sx_Close;
end;
function oDB.s(fnm:string): string;
begin
sx_Select(Area);
Result:=StrPas(sx_GetString(StrPCopy(StrNull1,fnm)))
end;
function oDB.st(fnm:string): string;
begin
sx_Select(Area);
Result:=StrPas(sx_GetTrimString(StrPCopy(StrNull1,fnm)))
end;
function oDB.sn(fnm:string;TruncTo:integer):string;
var tt:string;
begin
sx_Select(Area);
tt:=self.s(fnm);
if length(tt)<=TruncTo then Result:=Copy(tt,1,TruncTo)
else Result:=Padr(tt,TruncTo);
end;
function oDB.l(fnm:string): longint;
begin
sx_Select(Area);
Result:=sx_GetLong(StrPCopy(StrNull1,fnm))
end;
function oDB.i(fnm:string): integer;
begin
sx_Select(Area);
Result:=sx_GetInteger(StrPCopy(StrNull1,fnm))
end;
function oDB.b(fnm:string): boolean;
begin
sx_Select(Area);
Result:=tf(sx_GetLogical(StrPCopy(StrNull1,fnm)))
end;
function oDB.f(fnm:string): double;
begin
{ Minor bug: can't use sx_GetDouble yet }
{ S/B Result:=sx_GetDouble(StrPCopy(StrNull1,fnm)); }
sx_Select(Area);
Result:=ProcDbl(StrPas(sx_GetString(StrPCopy(StrNull1,fnm))))
end;
function oDB.n(fnm:string): double;
begin
{ Minor bug: can't use sx_GetDouble yet }
{ S/B Result:=sx_GetDouble(StrPCopy(StrNull1,fnm)); }
sx_Select(Area);
Result:=ProcDbl(StrPas(sx_GetString(StrPCopy(StrNull1,fnm))))
end;
procedure oDB.m(fnm:string;toPchar:pchar); { field info as Memo }
var tPchar:Pchar;
begin
sx_Select(Area);
tPchar:=sx_GetMemo(StrPCopy(StrNull1,fnm),0);
StrCopy(toPChar,tPchar);
sx_MemDealloc(tPchar);
end;
function oDB.d(fnm:string):longint; { date of form 04/15/95 }
begin
sx_Select(Area);
Result:=ctod(StrPas(sx_GetDateString(StrPCopy(StrNull1,fnm))))
end;
function oDB.ds(fnm:string):string;
var ll:longint;
begin
sx_Select(Area);
ll:=ctod(StrPas(sx_GetDateString(StrPCopy(StrNull1,fnm))));
if ll>0 then Result:=dshyph(ll)
else Result:=space(8);
end;
function oDB.dj(fnm:string):longint; { date as Julian date}
begin
sx_Select(Area);
Result:=sx_GetDateJulian(StrPCopy(StrNull1,fnm))
end;
procedure oDB.ss(fnm:string;newval:string);
begin
sx_Select(Area);
sx_Replace(StrPCopy(StrNull1,fnm),r_char,StrPCopy(StrNull2,newval));
end;
procedure oDB.ll(fnm:string;newval:longint);
begin
sx_Select(Area);
sx_Replace(StrPCopy(StrNull1,fnm),r_long,@newval);
end;
procedure oDB.ii(fnm:string;newval:integer);
begin
sx_Select(Area);
sx_Replace(StrPCopy(StrNull1,fnm),r_integer,@newval);
end;
procedure oDB.bb(fnm:string;newval:boolean);
var ii:integer;
begin
sx_Select(Area);
if newval then ii:=1
else ii:=0;
sx_Replace(StrPCopy(StrNull1,fnm),r_logical,@ii);
end;
procedure oDB.ff(fnm:string;newval:double);
begin
sx_Select(Area);
sx_Replace(StrPCopy(StrNull1,fnm),r_double,@newval);
end;
procedure oDB.nn(fnm:string;newval:double);
begin
sx_Select(Area);
sx_Replace(StrPCopy(StrNull1,fnm),r_double,@newval);
end;
procedure oDB.mm(fnm:string;newval:pchar);
var StrMemo:pchar;
begin
StrMemo:=StrAlloc(MaxMemoSize);
sx_Select(Area);
StrCopy(StrMemo,newval);
sx_Replace(StrPCopy(StrNull1,fnm),r_memo,StrMemo);
StrDispose(StrMemo);
end;
procedure oDB.longs(fnm:string;tp:Pchar); { char fields>255 in length }
var tPchar:Pchar;
begin
sx_Select(Area);
tPchar:=sx_GetString(StrPCopy(StrNull1,fnm));
StrCopy(tp,tPchar);
sx_MemDealloc(tPchar);
end;
procedure oDB.longss(fnm:string;tp:Pchar); { Char fields>255 in length }
begin
sx_Select(Area);
sx_Replace(StrPCopy(StrNull1,fnm),r_char,tp);
end;
procedure oDB.dd(fnm:string;newval:longint);
var tt:string;
begin
sx_Select(Area);
{ pass in longint of form 19950115, invalid dates force field to blank }
{ bug? in Delphi, must use defined var with StrPCopy, can't use
function call as second arg, this won't work right, no error caused:
StrPCopy(StrNull2,dtoc(newval) }
tt:=dtoc(newval);
sx_Replace(StrPCopy(StrNull1,fnm),r_datestr,StrPCopy(StrNull2,tt));
end;
function oDB.GetFullRecord:string;
{return raw data, first 255 bytes only }
var tchar,dest:pchar;
ii:longint;
begin
sx_Select(Area);
tchar:=stralloc(500);
dest:=stralloc(500);
sx_GetRecord(tchar);
ii:=sx_RecSize;
if ii>250 then ii:=250;
strlcopy(dest,tchar,ii);
result:=StrPas(dest);
strdispose(tchar);
strdispose(dest);
end;
function oDB.Alias:string;
begin
sx_Select(Area);
Result:=dbAlias;
end;
procedure oDB.Append;
begin
sx_Select(Area);
sx_AppendBlank;
end;
function oDB.Bof: boolean;
begin
sx_Select(Area);
result:=tf(sx_Bof);
end;
procedure oDB.GoBottom;
begin
sx_Select(Area);
sx_GoBottom;
end;
procedure oDB.Delete; { mark record as deleted }
begin
sx_Select(Area);
sx_Delete;
end;
function oDB.Deleted: boolean; { status of deletion flag of record }
begin
sx_Select(Area);
Result:=tf(sx_Deleted);
end;
function oDB.Eof: boolean;
begin
sx_Select(Area);
result:=tf(sx_Eof);
end;
procedure oDB.Go(RecNo:longint);
begin
sx_Select(Area);
sx_Go(RecNo);
end;
function oDB.LastRec: longint;
begin
sx_Select(Area);
Result:=sx_Reccount;
end;
function oDB.LockList(var locklist:array of longint):integer;
var lcnt:integer;
ptr:pointer;
begin
sx_Select(Area);
for lcnt:=0 to high(locklist) do locklist[lcnt]:=0;
ptr:=addr(locklist);
sx_DBRlockList(ptr);
Result:=sx_LockCount;
end;
function oDB.Lock: boolean; { try lock until succeeds }
var ii:integer;
res:boolean;
begin
sx_Select(Area);
while true do begin
res:=False;
ii:=0;
while (ii<2) and (not res) do { notify after 4 seconds }
begin
DoEvents2;
res:=tf(sx_rLock(sx_Recno));
if not res then delay(2);
pp(ii);
end;
if res then break else
OKBox('Attempt To Lock Failed For '+AliasName+
', Waiting, Please Check Around');
end;
Result:=res;
end;
function oDB.aLock: boolean; { try a few times then return }
var ii:integer;
res:boolean;
begin
sx_Select(Area);
ii:=0;
res:=False;
while (ii<2) and (not res) do { timeout=2*2=4 seconds }
begin
res:=tf(sx_rLock(sx_Recno));
if not res then delay(2);
pp(ii);
end;
Result:=res;
end;
procedure oDB.Pack;
begin
sx_Select(Area);
sx_Pack;
end;
procedure oDB.Recall; { unmark record as deleted }
begin
sx_Select(Area);
sx_Recall;
end;
procedure oDB.ReIndex;
begin
sx_Select(Area);
sx_ReIndex;
end;
function oDB.RecCount: longint;
begin
sx_Select(Area);
Result:=sx_RecCount;
end;
function oDB.RecNo: longint;
begin
sx_Select(Area);
Result:=sx_RecNo;
end;
function oDB.Seek(apattern:string): boolean;
begin
sx_Select(Area);
Result:=tf(sx_Seek(StrPCopy(StrNull1,apattern)));
end;
procedure oDB.SetOrder(ToIndex:integer);
begin
sx_Select(Area);
sx_SetOrder(ToIndex);
CurOrder:=ToIndex;
{ if CurOrder<>sx_IndexOrd then
OKBox('Index Order Not Set Correctly In '+AliasName); }
end;
procedure oDB.SetRelation(IntoAreaNum:integer;OnExpr:string);
begin
sx_Select(Area);
sx_SetRelation(IntoAreaNum,StrPCopy(StrNull1,OnExpr));
end;
procedure oDB.Skip;
begin
sx_Select(Area);
sx_Skip(1);
end;
procedure oDB.Skip2(ByCnt:integer);
begin
sx_Select(Area);
sx_Skip(ByCnt);
end;
procedure oDB.TagOrder(OrderByTag:String);
begin
sx_Select(Area);
sx_SetOrder(sx_TagArea(StrPCopy(StrNull1,OrderByTag)));
end;
procedure oDB.GoTop;
begin
sx_Select(Area);
sx_GoTop;
end;
procedure oDB.unLock;
begin
sx_Select(Area);
sx_Commit;
sx_unLock(sx_Recno);
end;
procedure oDB.Zap;
begin
sx_Select(Area);
sx_Zap;
end;
procedure StartDBserver;
begin
sx_SetHandles(MaxDBFs*2);
sx_SetStringType(1);
sx_SetDeleted(0); { show records marked as deleted }
StrNull1:=StrAlloc(255);
StrNull2:=StrAlloc(255);
DoEventsCnt:=0;
end;
end.